home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD Ware Multimedia 1995 May
/
cd Ware (Juegos) Epimundo.iso
/
DOS
/
PRGMMING
/
M2PROTOS.ZIP
/
QCZM.MOD
< prev
next >
Encoding:
Amiga
Atari
Commodore
DOS
FM Towns/JPY
Macintosh
Macintosh JP
Macintosh to JP
NeXTSTEP
RISC OS/Acorn
Shift JIS
UTF-8
Wrap
Modula Implementation
|
1993-10-06
|
37.8 KB
|
1,203 lines
(*# call(o_a_copy => off) *)
(*%T _fcall *)
(*# call(seg_name => QCxm) *)
(*%E *)
(*%F _fcall *)
(*# call(seg_name => null) *)
(*%E *)
(*# module(implementation=>on) *)
(*# data(seg_name => null) *)
(*# data(const_assign => on) *)
IMPLEMENTATION MODULE QCzm;
FROM QCcomm IMPORT bs, can, cr, lf, xon, xoff, CommRdData, CommWrData,
CommWrStr, CommRdDataTest, ComTimedOut, ComAbort, ComNoCarrier;
FROM FioAsm IMPORT DiskFree, PathStr, PathTail, SetFileTime, FileTime;
FROM QCdisp IMPORT QCDef, StatusMessage, IncrDataBytes, ShowTransferTime, Errs,
FlushLog, DataRegisters, ShowErrorType, ShowFileName, DataLeft, QCDefPtr,
ShowTimeLeft, Packets, StartDisplay, StopDisplay, Yes, YModem, ZModem;
FROM QCxm IMPORT ReceiveXmodem;
FROM NFIO IMPORT Create, Open, Close, File, RdBin, WrBin, OK, Seek,
SeekEOF, Exists, Size, EOF;
FROM UTIL IMPORT NUMSET, str32;
FROM CRC IMPORT DoCRC, DoC32;
FROM Com IMPORT commChar, SendBreak, Connected;
FROM QCxmzero IMPORT BPtr, CreateBlock, InterpretBlock, TelinkBlockType;
FROM RBvideo IMPORT Delay;
FROM MiscAsm IMPORT HI, LO, SWAP, LongNot;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM Str IMPORT Concat, Append;
FROM Lib IMPORT Move;
FROM Timer IMPORT StartTimer, ForTransfer, ForPacket;
TYPE
CmdType = (zrqinit, zrinit, zsinit, zack, zfile, zskip, znak, zabort,
zfin, zrpos, zdata, zeof, zferr, zcrc, zchallenge, zcompl,
zcan, zfreecnt, zcommand, zstderr, canceled,
timedout, userabort, disconnected, zok, zerror );
ZRQinitRec = RECORD
xxx : ARRAY[0..2] OF BYTE;
CmdFlag: CmdType;
END;
RFlagType = SET OF (CanFDX, CanOvIO, CanBrk, CanCry, CanLzw, CanFC32,
EscCtl, Esc8);
ZRinitRec = RECORD
RBufSize: CARDINAL;
xxx : BYTE;
RFlags: RFlagType
END;
SFlagType = SET OF ( SF0, SF1, SF2, SF3, SF4, SF5, TEscCtl, TEsc8 );
ZSinitRec = RECORD
xxx : ARRAY[0..2] OF BYTE;
SFlags: SFlagType;
END;
CFlagType = (CfEmpty, CfNoConv, CfNLtoCRLF, CfResume);
MFlagType1 = (MEmpty, IfNewLong, IfCRC, IfAppend, IfReplace, IfNew);
MFlagType2 = SET OF ( MF0, MF1, MF2, MF3, MF4, MF5, MF6, MSkipIfAbs );
TFlagType = (TEmpty, TLZW, TCrypt, TRLE );
ZFileRec = RECORD
XFlags: SET OF (XF0, XF1, XF2, XF3, XF4, XF5, Sparse);
TFlags: TFlagType;
CASE : BOOLEAN OF
TRUE : MFlags1: MFlagType1;
|FALSE: MFlags2: MFlagType2;
END;
CFlags: CFlagType;
END;
ZCommandRec = RECORD
xxx : ARRAY[0..2] OF BYTE;
CAck : BOOLEAN;
END;
HeaderType = RECORD
CASE : BOOLEAN OF
|FALSE : H : ARRAY[0..8] OF BYTE;
|TRUE :
CASE Cmd: CmdType OF
zrqinit : ZRQinit : ZRQinitRec;
|zrinit : ZRinit : ZRinitRec;
|zsinit : ZSinit : ZSinitRec;
|zfile : ZFile : ZFileRec;
|zcommand : ZCommand: ZCommandRec;
|zack, zrpos, zdata, zeof, zcrc, zchallenge, zcompl: P : LONGCARD;
END;
CASE : BOOLEAN OF
|FALSE: crc16: CARDINAL;
|TRUE : crc32: LONGCARD;
END;
END
END;
(*# save *)
(*# call (near_call => on) *)
ZSendHeaderType = PROCEDURE (CmdType);
ZReceiveDataType = PROCEDURE ( BPtr, INTEGER): CARDINAL;
CONST
StdRecvRatio = 0; (* Max num of blocks to send without Ack; 0 = infinite *)
ZBUFSIZE = 1024;
ZPAD = 42; (* '*' *) ZBIN = 65; (* 'A' *)
ZDLE = 24; (* ^X *) ZHEX = 66; (* 'B' *)
ZDLEE = 88; ZBIN32 = 67; (* 'C' *)
ZCRCE = 104; (* 'h' *) ZCRCW = 107; (* 'k' *)
ZCRCG = 105; (* 'i' *) ZRUB0 = 108; (* 'l' *)
ZCRCQ = 106; (* 'j' *) ZRUB1 = 109; (* 'm' *)
BadChar = 0FFFFH; (* received bad info or bad CRC *)
GotOR = 100H; GotCan = GotOR + can;
GotCRCE = GotOR + ORD('h'); GotCRCQ = GotOR + ORD('j');
GotCRCG = GotOR + ORD('i'); GotCRCW = GotOR + ORD('k');
ZRinitVals = ZRinitRec( 0, BYTE(0),
RFlagType{ CanFDX, CanOvIO, CanBrk, CanFC32 });
VAR
rxhdr,
txhdr: HeaderType;
HdrErrCount, (* Error count for headers, set on entry *)
rxcount,
rxtimeout : CARDINAL;
attn : str32;
Buffer: BPtr;
ZeroBlock: TelinkBlockType;
ZSendHeader : ZSendHeaderType;
ZReceiveData : ZReceiveDataType;
PROCEDURE ZFileCRC32(VAR f: File): LONGCARD;
VAR crc: LONGCARD; result: CARDINAL;
BEGIN
crc := 0FFFFFFFFH;
Seek(f,0);
REPEAT
result := RdBin(f,Buffer^,ZBUFSIZE);
crc := DoC32(Buffer, result, crc)
UNTIL (result < ZBUFSIZE) OR (NOT OK);
Seek(f,0);
RETURN crc
END ZFileCRC32;
PROCEDURE ZTimedRead(): CARDINAL;
(* strips parity and ignores xon/xoff characters.*)
VAR c: CARDINAL;
BEGIN
REPEAT
c := CommRdDataTest(rxtimeout);
UNTIL (c>0FF00H)
OR NOT (SHORTCARD(c) IN NUMSET{xon,xoff,91H,93H});(* not xon/xoff *)
RETURN c
END ZTimedRead;
PROCEDURE ZSendCan;
(* Send a zmodem cancel sequence: 8 cans and 8 backspaces *)
VAR n: SHORTCARD;
BEGIN
FOR n := 1 TO 8 DO
CommWrData(can);
Delay(100)
END;
FOR n := 1 TO 8 DO
CommWrData(bs)
END
END ZSendCan;
PROCEDURE ZPutString(p: ARRAY OF CHAR);
VAR n: CARDINAL;
BEGIN
n := 0;
WHILE (n <= HIGH(p)) AND (p[n] > 0C) DO
CASE p[n] OF
335C : SendBreak;
|336C : Delay(2000)
|ELSE CommWrData(p[n])
END;
INC(n)
END;
CommWrData(0)
END ZPutString;
PROCEDURE ZPutHex(b: BYTE);
CONST hex = '0123456789abcdef';
BEGIN
CommWrData(hex[ORD(b) >> 4]);
CommWrData(hex[ORD(b) MOD 10H])
END ZPutHex;
PROCEDURE ZSendHexHeader(C: CmdType);
CONST SendHex = '**' + 30C + 'B'; HexEnd = 15C + 12C;
VAR crc: CARDINAL; n: CARDINAL;
BEGIN
txhdr.Cmd := C;
txhdr.crc16 := SWAP(DoCRC(ADR(txhdr), 5, 0));
n := CommWrStr(SendHex);
FOR n := 0 TO 6 DO
ZPutHex(txhdr.H[n]);
END;
n := CommWrStr(HexEnd);
IF (C <> zfin) AND (C <> zack) THEN
CommWrData(xon); (* to assure flow *)
END;
END ZSendHexHeader;
PROCEDURE ZSendBytes(V : ARRAY OF BYTE; count : CARDINAL);
VAR LastWas40H : BOOLEAN; i : CARDINAL; b: SHORTCARD;
BEGIN
IF count = 0 THEN
RETURN
END;
LastWas40H := FALSE;
FOR i := 0 TO count -1 DO
b := SHORTCARD(V[i]);
IF (b IN NUMSET{10H,11H,13H,18H,90H,91H,93H,98H}) OR
(LastWas40H AND (b IN NUMSET{0FH, 8FH})) THEN
INCL(BITSET(b), 6);
CommWrData(ZDLE);
END;
CommWrData(b);
LastWas40H := SHORTCARD(b) = 40H
END;
END ZSendBytes;
PROCEDURE ZSendHeader32(C: CmdType);
CONST SendBin32Str = '*' + 30C + 'C';
VAR n: CARDINAL;
BEGIN
txhdr.Cmd := C;
txhdr.crc32 := LongNot(DoC32(ADR(txhdr), 5, 0FFFFFFFFH));
n := CommWrStr(SendBin32Str);
ZSendBytes(txhdr, 9);
IF C <> zdata THEN
Delay(500)
END
END ZSendHeader32;
PROCEDURE ZSendHeader16(C: CmdType);
CONST SendBinStr = '*' + 30C + 'A';
VAR crc, n: CARDINAL;
BEGIN
txhdr.Cmd := C;
txhdr.crc16 := SWAP(DoCRC(ADR(txhdr), 5, 0));
n := CommWrStr(SendBinStr);
ZSendBytes(txhdr, 7);
IF C <> zdata THEN
Delay(500)
END
END ZSendHeader16;
PROCEDURE ZGetZDL(): CARDINAL;
(* Gets byte and processes for ZMODEM escaping or cancel sequence *)
VAR c, n: CARDINAL;
BEGIN
c := CommRdDataTest(rxtimeout);
IF c <> ZDLE THEN
RETURN c
END; (*got ZDLE or 1st can*)
n := 0;
REPEAT
c := CommRdData(rxtimeout);
INC(n);
UNTIL (n >= 5) OR (c <> ZDLE);
(* Flags set in high byte *)
CASE c OF
can: RETURN GotCan; (* 5th can, same as ZDLE *)
|ZCRCE, (*frame end marker*)
ZCRCG,
ZCRCQ,
ZCRCW: RETURN c + GotOR;
|ZRUB0: RETURN 007FH; (*got an ASCII DELete*)
|ZRUB1: RETURN 00FFH (*any parity *)
|ELSE IF c > 0FF00H THEN
RETURN c
ELSIF (6 IN BITSET(c)) AND (NOT (5 IN BITSET(c))) THEN
RETURN c - 40H
ELSE
RETURN BadChar
END
END
END ZGetZDL;
PROCEDURE ZReceiveDa32(buf: BPtr; blength: INTEGER): CARDINAL;
(* Returns frame end character *)
VAR c, FrameEnd, n: CARDINAL; crc: LONGCARD;
BEGIN
rxcount := 0;
LOOP
c := ZGetZDL();
IF c >= 100H THEN
EXIT
END;
DEC(blength);
IF (blength < 0) THEN
StatusMessage('Packet is too long', FALSE);
RETURN BadChar;
END;
INC(rxcount);
buf^[rxcount] := BYTE(c);
END; (* LOOP *)
IF (c >= GotCRCE) AND (c <= GotCRCW) THEN
FrameEnd := c;
INC(rxcount);
buf^[rxcount] := BYTE(c);
n := 1;
LOOP
c := ZGetZDL();
IF c > 100H THEN
DEC(rxcount, n); (* subtract FrameEnd and CRC *)
EXIT
END;
INC(rxcount);
buf^[rxcount] := BYTE(c);
INC(n);
IF n > 4 THEN
crc := DoC32(buf, rxcount, 0FFFFFFFFH);
DEC(rxcount, n); (* subtract FrameEnd and CRC *)
INC( DataRegisters[TRUE, Packets]);
IF crc <> 0DEBB20E3H THEN
INC(DataRegisters[ TRUE, Errs]);
RETURN BadChar
ELSE
RETURN FrameEnd;
END;
END;
END;
END;
CASE c OF
|GotCan : StatusMessage('Transfer canceled', FALSE);
RETURN c;
|ComTimedOut,
ComAbort : RETURN c;
|ComNoCarrier : StatusMessage('Lost carrier', TRUE);
RETURN c;
ELSE WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
RETURN c
END; (* CASE *)
END ZReceiveDa32;
PROCEDURE ZReceiveDa16(buf: BPtr; blength: INTEGER): CARDINAL;
(* Returns frame end character *)
VAR c, crc, n, FrameEnd : CARDINAL;
BEGIN
rxcount := 0;
LOOP
c := ZGetZDL();
IF c >= 100H THEN
EXIT
END;
DEC(blength);
IF (blength < 0) THEN
StatusMessage('Packet is too long', FALSE);
RETURN BadChar;
END;
INC(rxcount);
buf^[rxcount] := BYTE(c);
END; (* LOOP *)
IF (c >= GotCRCE) AND (c <= GotCRCW) THEN
INC(rxcount);
buf^[rxcount] := BYTE(c);
FrameEnd := c;
n := 1;
LOOP
c := ZGetZDL();
IF c > 100H THEN
DEC(rxcount, n); (* Take off FrameEnd, crc *)
EXIT
END;
INC(rxcount);
buf^[rxcount] := BYTE(c);
INC(n);
IF n > 2 THEN
crc := DoCRC(buf, rxcount, 0);
DEC(rxcount, n); (* Take off FrameEnd, crc *)
INC( DataRegisters[TRUE, Packets]);
IF crc > 0 THEN
INC(DataRegisters[ TRUE, Errs]);
RETURN BadChar
ELSE
RETURN FrameEnd
END;
END;
END;
END;
CASE c OF
|GotCan : StatusMessage('Transfer canceled', FALSE);
RETURN c;
|ComTimedOut,
ComAbort : RETURN c;
|ComNoCarrier : StatusMessage('Lost carrier', TRUE);
RETURN c;
ELSE WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
RETURN c
END; (* CASE *)
END ZReceiveDa16;
PROCEDURE ZGetHeader(): CmdType;
TYPE GetHedStateType = (GetZpad, GetZdle, GetFrame);
VAR c, errcount, cancount: CARDINAL; HedState : GetHedStateType;
HaveGarbage: BOOLEAN;
PROCEDURE ZGetHexHeader(): CmdType;
VAR crc, c, n: CARDINAL;
PROCEDURE ZGetHex(): CARDINAL;
VAR c, n: CARDINAL;
BEGIN
n := ZTimedRead();
IF n > 100H THEN
RETURN n
END;
DEC(n, 30H);
IF (n > 9) THEN
DEC(n, 39)
END;
IF (n > 0FH) OR (n < 0) THEN
RETURN BadChar;
END;
c := ZTimedRead();
IF c > 100H THEN
RETURN c
END;
DEC(c, 30H);
IF c > 9 THEN
DEC(c, 39);
END;
IF (c > 0FH) OR (c < 0) THEN
RETURN BadChar;
END;
RETURN (n << 4) + c
END ZGetHex;
BEGIN
FOR n := 0 TO 6 DO
c := ZGetHex();
IF c > 0FF00H THEN
CASE c OF
ComNoCarrier : RETURN disconnected;
|ComTimedOut : RETURN timedout;
|ComAbort : RETURN userabort;
|GotCan : RETURN canceled;
END;
END;
rxhdr.H[n] := BYTE(c);
END;
crc := DoCRC(ADR(rxhdr), 7, 0);
IF (crc > 0) THEN
INC(DataRegisters[ TRUE, Errs]);
rxhdr.Cmd := zerror;
END;
IF CommRdData(1) = ORD(cr) THEN (*throw away CR/LF*)
c := CommRdData(1)
END;
RETURN rxhdr.Cmd
END ZGetHexHeader;
PROCEDURE ZGetBinaryHeader(): CmdType;
VAR crc, n, c: CARDINAL;
BEGIN
FOR n := 0 TO 6 DO
c := ZGetZDL();
IF c >= 100H THEN
CASE c OF
ComNoCarrier : RETURN disconnected;
|ComTimedOut : RETURN timedout;
|ComAbort : RETURN userabort;
|GotCan : RETURN canceled;
END;
END;
rxhdr.H[n] := SHORTCARD(c);
END;
crc := DoCRC(ADR(rxhdr),7, 0);
IF crc > 0 THEN
INC(DataRegisters[ TRUE, Errs]);
rxhdr.Cmd := zerror;
END;
RETURN rxhdr.Cmd
END ZGetBinaryHeader;
PROCEDURE ZGetBinaryHead32(): CmdType;
VAR crc: LONGCARD; c, n: CARDINAL;
BEGIN
FOR n := 0 TO 8 DO
c := ZGetZDL();
IF c >= 100H THEN
CASE c OF
ComNoCarrier : RETURN disconnected;
|ComTimedOut : RETURN timedout;
|ComAbort : RETURN userabort;
|GotCan : RETURN canceled;
END;
END;
rxhdr.H[n] := SHORTCARD(c);
END;
crc := DoC32(ADR(rxhdr),9, 0FFFFFFFFH);
IF (crc <> 0DEBB20E3H) THEN
INC(DataRegisters[ TRUE, Errs]);
rxhdr.Cmd := zerror;
END;
RETURN rxhdr.Cmd
END ZGetBinaryHead32;
BEGIN (* ZGetHeader *)
errcount := HdrErrCount;
HedState := GetZpad;
cancount := 4;
HaveGarbage := FALSE;
LOOP
c := ZTimedRead();
CASE HedState OF
|GetZpad: IF c = ZPAD THEN
INC(HedState)
ELSE
HaveGarbage := TRUE;
END;
|GetZdle: CASE c OF
|ZDLE: INC(HedState)
|ZPAD: ; (* deja vu *)
|ELSE HaveGarbage := TRUE;
END;
|GetFrame: CASE c OF
ZBIN32: ZReceiveData := ZReceiveDa32;
RETURN ZGetBinaryHead32();
|ZBIN: ZReceiveData := ZReceiveDa16;
RETURN ZGetBinaryHeader();
|ZHEX: RETURN ZGetHexHeader();
|ELSE HaveGarbage := TRUE;
END;
END; (* CASE HedState *)
WHILE HaveGarbage DO
CASE c OF
|ComNoCarrier: RETURN disconnected;
|ComTimedOut: RETURN timedout;
|ComAbort: RETURN userabort;
|can: DEC(cancount);
IF (cancount = 0) THEN
RETURN canceled;
END;
c := ZTimedRead();
|ELSE DEC(errcount);
IF errcount = 0 THEN
INC(DataRegisters[ TRUE, Errs]);
StatusMessage('Header is bad', FALSE);
RETURN zerror;
END;
cancount := 4; (* restore *)
HaveGarbage := FALSE; (* reset *)
IF c = ZPAD THEN
HedState := GetZdle
ELSE
HedState := GetZpad; (* Start over *)
END;
END; (* CASE *)
END; (* WHILE *)
END; (* ZPAD LOOP *)
END ZGetHeader;
(*# restore *)
(*---------*)
(* RECEIVE *)
(*---------*)
PROCEDURE ReceiveZmodem( FilePath : PathStr );
VAR
Fo: File;
filestart: LONGCARD;
zconversion: CFlagType;
PROCEDURE RecvAckExit;
VAR n: CARDINAL;
BEGIN
txhdr.P := rxhdr.P;
n := 4;
WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
LOOP
ZSendHexHeader(zfin);
CASE CommRdData(20) OF
|ComTimedOut,
ComAbort,
ComNoCarrier: RETURN;
|79: IF (CommRdData(10) = 79) THEN END;
EXIT;
|ELSE EXIT
END; (* CASE *)
IF n = 0 THEN EXIT END;
END; (* LOOP *)
WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
END RecvAckExit;
PROCEDURE InitReceiver(TryZHdr: CmdType): CmdType;
(* possible returns: zfile: zero block has file info;
timedout: sender not responding; try YModem;
zerror: no sender or transfer aborted;
zcompl: sender is finished *)
VAR c, TimeOuts : CARDINAL; SetZero : BOOLEAN;
BEGIN
attn[0] := 0C;
TimeOuts := 0;
SetZero := TRUE; (* Default is send zero in header flags *)
LOOP
IF TryZHdr = zrinit THEN
txhdr.ZRinit := ZRinitVals
ELSIF SetZero THEN
txhdr.P := 0
ELSE
SetZero := TRUE;
END;
ZSendHexHeader(TryZHdr);
IF TryZHdr = zskip THEN
TryZHdr := zrinit
END;
CASE ZGetHeader() OF
zfile: zconversion := rxhdr.ZFile.CFlags;
TryZHdr := zrinit;
c := ZReceiveData(Buffer,ZBUFSIZE);
IF (c = GotCRCW) THEN
RETURN zfile;
END;
TryZHdr := znak;
|zsinit: c := ZReceiveData(ADR(attn),SIZE(attn));
IF (c = GotCRCW) THEN
TryZHdr := zack;
ELSE
TryZHdr := znak;
END;
|zfreecnt: txhdr.P := DiskFree(0, c); (* use c as dummy variable *)
SetZero := FALSE; (* don't overwrite DiskFree *)
|zcommand: c := ZReceiveData(Buffer,ZBUFSIZE);
IF (c = GotCRCW) THEN
TryZHdr := zcompl;
ELSE
TryZHdr := znak;
END;
|zcompl,
zfin: RETURN zcompl;
|canceled,
userabort,
disconnected : RETURN zerror;
|timedout : INC(TimeOuts);
IF TimeOuts > 3 THEN
StatusMessage('Timeout', FALSE);
RETURN timedout;
END;
END (* CASE *)
END (* LOOP *)
END InitReceiver;
PROCEDURE GetFileInfo(): CmdType;
VAR tsize: LONGCARD; s, fname: PathStr;
(* returns zack to continue download; zskip to skip; zerror to abort *)
PROCEDURE CrcsMatch(): BOOLEAN;
VAR tries: CARDINAL;
BEGIN
txhdr.P := ZFileCRC32(Fo);
tries := 4;
LOOP
ZSendHexHeader(zcrc);
IF ZGetHeader() = zcrc THEN
RETURN txhdr.P = rxhdr.P
END;
DEC(tries);
IF tries = 0 THEN
RETURN FALSE
END
END;
END CrcsMatch;
BEGIN
InterpretBlock[ZModem] (Buffer, ZeroBlock );
Concat( fname, FilePath, ZeroBlock.FileName);
IF Exists(fname) THEN
Fo := Open(fname);
tsize := Size(Fo);
IF (Fo = MAX(CARDINAL)) OR NOT OK THEN
StatusMessage('Error opening file', TRUE);
RETURN zerror;
END;
IF (zconversion = CfResume) AND (ZeroBlock.FileLength > tsize)
AND (ZeroBlock.FileTime = FileTime(Fo))
AND Yes('File exists. Do you wish to resume downloading?') THEN
filestart := tsize;
SeekEOF(Fo);
StatusMessage('Recovering', FALSE)
ELSIF (ZeroBlock.FileLength = tsize) AND CrcsMatch() THEN
Concat(s, fname, ' is already complete');
StatusMessage(s, TRUE);
Close(Fo);
RETURN zskip;
ELSIF Yes('File exists. Do you wish to overwrite it?') THEN
filestart := 0;
Fo := Create(fname);
IF Fo = MAX(CARDINAL) THEN
StatusMessage('Unable to create file', TRUE);
RETURN zerror
END
ELSE
Close(Fo);
RETURN zskip;
END
ELSE
filestart := 0;
Fo := Create(fname);
IF Fo = MAX(CARDINAL) THEN
StatusMessage('Unable to create file', TRUE);
RETURN zerror
END
END;
ShowFileName(fname, TRUE);
DataRegisters[TRUE, DataLeft] := ZeroBlock.FileLength;
ShowTimeLeft( TRUE );
RETURN zack
END GetFileInfo;
PROCEDURE ZReceiveFile(): CmdType;
(* possible returns: zerror: any error;
zrinit: successfully completed -- passed to InitReceiver
zskip: transfer skipped *)
VAR c: CmdType; d, tries: CARDINAL; rxbytes: LONGCARD;
PROCEDURE SaveToDisk(VAR rx: LONGCARD): BOOLEAN;
BEGIN
WrBin(Fo,Buffer^,rxcount);
IF NOT OK THEN
StatusMessage('Disk write error', TRUE);
RETURN FALSE
END;
INC(rx, VAL(LONGCARD, rxcount));
IncrDataBytes( rxcount, TRUE );
RETURN TRUE
END SaveToDisk;
BEGIN (* ZReceiveFile *)
CASE GetFileInfo() OF
zskip : RETURN zskip;
|zerror : RETURN zerror;
END;
c := zack;
tries := 10;
rxbytes := filestart;
txhdr.P := rxbytes;
ZSendHexHeader(zrpos);
StartTimer(ForPacket);
StartTimer(ForTransfer);
LOOP
CASE ZGetHeader() OF
zdata: IF (rxhdr.P <> rxbytes) THEN
INC(DataRegisters[ TRUE, Errs]);
IF (tries = 0) THEN
RETURN zerror
END;
DEC(tries);
StatusMessage('Bad position', TRUE);
ZPutString(attn);
txhdr.P := rxbytes;
ZSendHexHeader(zrpos);
ELSE
LOOP
d := ZReceiveData(Buffer,ZBUFSIZE);
CASE d OF
|GotCan,
ComAbort,
ComNoCarrier: RETURN zerror;
|ComTimedOut: IF tries = 0 THEN
RETURN zerror
END;
DEC(tries);
txhdr.P := rxbytes;
ZSendHexHeader(zrpos);
EXIT;
|GotCRCE..GotCRCW: tries := 10;
IF NOT SaveToDisk(rxbytes) THEN
RETURN zerror
END;
IF (d = GotCRCQ) OR (d = GotCRCW) THEN
txhdr.P := rxbytes;
ZSendHexHeader(zack);
END;
IF (d = GotCRCW) OR (d = GotCRCE) THEN
EXIT;
END;
ELSE INC(DataRegisters[TRUE, Errs]); (* Debris *)
IF tries = 0 THEN
RETURN zerror;
END;
DEC(tries);
ZPutString(attn);
txhdr.P := rxbytes;
ZSendHexHeader(zrpos);
EXIT;
END (*CASE*)
END (* LOOP *)
END; (* ELSE *)
|znak,
timedout: IF tries = 0 THEN
RETURN zerror
END;
DEC(tries);
txhdr.P := rxbytes;
ZSendHexHeader(zrpos);
|zfile: d := ZReceiveData(Buffer,ZBUFSIZE);
txhdr.P := rxbytes;
ZSendHexHeader(zrpos);
|zeof: IF rxhdr.P = rxbytes THEN
RETURN zrinit (* passed to InitReceiver *)
END;
|zerror: IF tries = 0 THEN
RETURN zerror
END;
DEC(tries);
ZPutString(attn);
txhdr.P := rxbytes;
ZSendHexHeader(zrpos);
|ELSE RETURN zerror
END (*CASE*)
END; (* LOOP *)
END ZReceiveFile;
VAR c: CmdType;
BEGIN (* ReceiveZmodem *)
HdrErrCount := 600 << ORD(QCDefPtr^.baud);
WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
FlushLog;
StartDisplay( TRUE, ZModem, TRUE);
NEW ( Buffer );
rxtimeout := 100;
CASE InitReceiver(zrinit) OF
timedout: (* QCDefPtr^.Protocol *) QCDef.Protocol := YModem;
StatusMessage('No ZModem response; Trying YModem', FALSE);
DISPOSE( Buffer );
StopDisplay;
ReceiveXmodem( FilePath, '' );
(* QCDefPtr^.Protocol *) QCDef.Protocol := ZModem;
RETURN;
|zerror: StatusMessage('Aborting transfer', FALSE);
DISPOSE( Buffer );
StopDisplay;
RETURN;
|zcompl: StatusMessage('Transfer complete', FALSE);
DISPOSE( Buffer );
StopDisplay;
RETURN;
END;
LOOP
c := ZReceiveFile();
IF SetFileTime(Fo,ZeroBlock.FileTime) THEN END;
ShowTransferTime;
Close(Fo);
CASE c OF
|zrinit,
zskip: CASE InitReceiver(c) OF
|zfile:; (* go through next loop *);
|zcompl: RecvAckExit;
EXIT;
|ELSE StatusMessage('Canceling transmission', FALSE);
ZSendCan;
EXIT
END;
|ELSE EXIT;
END (*CASE*)
END; (*LOOP*)
DISPOSE( Buffer );
StopDisplay;
END ReceiveZmodem;
(* SEND *)
(*# save *)
(*# call (near_call => on) *)
TYPE
ZSendDataType = PROCEDURE ( BPtr, CARDINAL, SHORTCARD);
PROCEDURE ZSendDa32(buf: BPtr; blength: CARDINAL; FrameEnd: SHORTCARD);
VAR n: CARDINAL; crc: LONGCARD;
BEGIN
n := blength + 1;
buf^[n] := FrameEnd; (* put this at end to calculate *)
crc := LongNot(DoC32(buf, n, 0FFFFFFFFH));
ZSendBytes(buf^, blength);
CommWrData(ZDLE);
CommWrData(FrameEnd);
ZSendBytes(crc, 4);
INC( DataRegisters[FALSE, Packets]);
IF FrameEnd = ZCRCW THEN
CommWrData(xon);
Delay(500)
END
END ZSendDa32;
PROCEDURE ZSendDa16( buf: BPtr; blength: CARDINAL; FrameEnd: SHORTCARD);
VAR crc, n: CARDINAL;
BEGIN
n := blength + 1;
buf^[n] := FrameEnd; (* put this at end to calculate *)
crc := SWAP(DoCRC(buf, blength+1, 0 ));
ZSendBytes(buf^, blength);
CommWrData(ZDLE);
CommWrData(FrameEnd);
ZSendBytes(crc, 2);
INC( DataRegisters[FALSE, Packets]);
IF (ORD(FrameEnd) = ZCRCW) THEN
CommWrData(xon);
Delay(500)
END
END ZSendDa16;
(*# restore *)
PROCEDURE SendZmodem( ThisFile: FilePtr );
VAR
Fi : File;
BlockZeroLen,
BlockLength, (* length of next sub-block to send *)
MaxLength, (* maximum length of any sub-block *)
RecvRatio : CARDINAL; (* number of sub-blocks receiver can swallow at once *)
txpos : LONGCARD;
ZSendData : ZSendDataType;
PROCEDURE SendAckExit;
VAR dummy: CARDINAL;
BEGIN
txhdr.P := txpos;
LOOP
ZSendHeader(zfin);
CASE ZGetHeader() OF
zfin: dummy := CommWrStr('OO');
Delay(500);
(* ClearOutput; *)
RETURN
|canceled,
userabort,
disconnected,
zferr,
timedout: RETURN
END (*CASE*)
END (* LOOP *)
END SendAckExit;
PROCEDURE GetReceiverInfo(): BOOLEAN;
CONST StartStr = 'rz'+15C;
VAR rxflags, n: CARDINAL;
BEGIN
attn[0] := 0C;
txhdr.P := 0;
ZPutString(StartStr);
n := 10;
ZSendHexHeader(zrqinit);
LOOP
CASE ZGetHeader() OF
zchallenge: txhdr.P := rxhdr.P;
ZSendHexHeader(zack);
|zcommand: txhdr.P := 0;
ZSendHexHeader(zrqinit);
|zrinit: IF rxhdr.ZRinit.RBufSize > 0 THEN
IF rxhdr.ZRinit.RBufSize < MaxLength THEN
MaxLength := rxhdr.ZRinit.RBufSize
END;
RecvRatio := rxhdr.ZRinit.RBufSize MOD MaxLength;
ELSE
RecvRatio := StdRecvRatio
END;
IF CanFC32 IN rxhdr.ZRinit.RFlags THEN
ZSendHeader := ZSendHeader32;
ZSendData := ZSendDa32;
END;
ShowErrorType(TRUE); (* Change to show usecrc32 *);
RETURN TRUE
|canceled,
disconnected,
userabort: RETURN FALSE;
|timedout: StatusMessage('Timeout on initialization.', FALSE);
ZSendHexHeader(zrqinit);
|zrqinit: IF rxhdr.ZRQinit.CmdFlag <> zcommand THEN
RETURN FALSE
END;
|ELSE ZSendHexHeader(znak);
END; (* CASE *)
DEC(n);
IF n = 0 THEN
RETURN FALSE
END;
END; (* LOOP *)
END GetReceiverInfo;
PROCEDURE ZSendFile(): CmdType;
PROCEDURE ZSendFileData(): CmdType;
(* returns zerror, zskip or zok *)
TYPE SendStateType = (SendDHdr, SendSubBlock, SendEOF, EOFSent);
VAR c: CmdType; WaitAck : BOOLEAN; SendState : SendStateType; Quality: INTEGER;
errcheck, BlockRead, RecvCycle: CARDINAL; HighestPos: LONGCARD;
PROCEDURE ZSendResync(): CmdType;
(* Returns zack, zskip, zrpos, zrinit or zerror *)
VAR Cd: CmdType;
BEGIN
Cd := ZGetHeader();
WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
CASE Cd OF
|zrpos: Seek(Fi,rxhdr.P);
IF NOT OK THEN
StatusMessage('File seek error', FALSE);
RETURN zerror;
END;
txpos := rxhdr.P;
DEC(Quality);
RETURN zrpos;
|zskip: RETURN zskip;
|canceled,
timedout,
zabort,
zfin,
userabort,
disconnected: RETURN zerror;
|zrinit: RETURN zrinit;
|zack: RETURN zack;
|ELSE ZSendHeader(znak)
END (*CASE*)
END ZSendResync;
BEGIN (* ZSendFileData *)
WaitAck := FALSE;
SendState := SendDHdr;
Quality := 0;
HighestPos := txpos;
LOOP (* Main *)
IF WaitAck OR commChar() THEN
c := ZSendResync();
CASE c OF
zskip: RETURN zskip;
|zack: ; (*null*)
|zrpos: INC(DataRegisters[FALSE, Errs]);
DEC(Quality);
IF BlockLength > 80H THEN
BlockLength := BlockLength >> 2
ELSE
BlockLength := 20H
END;
IF SendState = SendSubBlock THEN
ZSendData(Buffer, 0, ZCRCE);
SendState := SendDHdr;
END;
|zrinit: RETURN zrinit;
|ELSE RETURN zerror;
END (*CASE*);
ELSE
c := zack (* no news is good news *)
END;
CASE SendState OF
SendDHdr: txhdr.P := txpos;
ZSendHeader(zdata);
INC(SendState);
RecvCycle := 0;
|SendSubBlock: BlockRead := RdBin(Fi, Buffer^, BlockLength);
INC(RecvCycle);
IF EOF(Fi) THEN
errcheck := ZCRCE;
WaitAck := FALSE;
INC(SendState);
(*DIAG: EOF error here?*)
ELSIF NOT OK THEN
StatusMessage('Error reading disk', FALSE);
ZSendCan;
RETURN zerror;
ELSIF (RecvRatio > 0) AND (RecvCycle = RecvRatio) THEN
RecvCycle := 0;
errcheck := ZCRCQ
ELSE
errcheck := ZCRCG
END;
ZSendData(Buffer, BlockRead, SHORTCARD(errcheck));
INC(txpos, VAL(LONGCARD,BlockRead));
IncrDataBytes( BlockRead, FALSE );
INC(Quality);
IF (BlockLength < MaxLength) AND (Quality > 0)
AND (txpos > HighestPos) THEN
IF ((BlockLength << 1) < MaxLength) THEN
BlockLength := (BlockLength << 1)
ELSE
BlockLength := MaxLength
END;
END;
WaitAck := (errcheck= ZCRCQ) OR (errcheck= ZCRCW);
|SendEOF: txhdr.P := txpos;
ZSendHeader(zeof);
INC(SendState);
WaitAck := TRUE;
|EOFSent: CASE c OF
zack: SendState := SendEOF; (* await response *)
|zrpos: SendState := SendDHdr;(* receiver not done*)
ELSE RETURN c
END
END (* CASE *)
END (* Main LOOP *)
END ZSendFileData;
BEGIN (* ZSendFile *)
txpos := 0;
txhdr.P := 0;
txhdr.ZFile.CFlags := CfResume;
ZSendHeader(zfile);
ZSendData(Buffer, BlockZeroLen, ZCRCW);
StartTimer(ForTransfer);
StartTimer(ForPacket);
LOOP
CASE ZGetHeader() OF
zcan,
disconnected,
canceled,
timedout,
zfin,
userabort,
zabort: RETURN zerror;
|zrinit: ;(*null; stay in loop *)
|zcrc: txhdr.P := ZFileCRC32(Fi);
ZSendHexHeader(zcrc)
|zskip: RETURN zskip;
|zrpos: Seek(Fi,rxhdr.P);
IF NOT OK THEN
StatusMessage('File positioning error', FALSE);
ZSendHexHeader(zferr);
RETURN zferr;
END;
txpos := rxhdr.P;
RETURN ZSendFileData();
|ELSE ZSendHeader(zfile);
ZSendData(Buffer, BlockZeroLen, ZCRCW);
END (*CASE*)
END (* LOOP *)
END ZSendFile;
VAR Cd : CmdType; FileName: PathTail; GotFile: BOOLEAN;
BEGIN
rxtimeout := 192 >> ORD(QCDefPtr^.baud);
IF rxtimeout < 10 THEN
rxtimeout := 10
END;
HdrErrCount := 600 << ORD(QCDefPtr^.baud);
WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
FlushLog;
NEW( Buffer );
StartDisplay( TRUE, ZModem, FALSE );
ZSendHeader := ZSendHeader16;
ZSendData := ZSendDa16;
MaxLength := ZBUFSIZE; (* assumes maximum *)
IF NOT GetReceiverInfo() THEN
DISPOSE( Buffer );
StopDisplay;
RETURN
END;
IF (MaxLength = 0) OR (MaxLength > ZBUFSIZE) THEN
MaxLength := ZBUFSIZE (* if can't user receiver info, use ours *)
END;
IF QCDefPtr^.baud < 3 (*2400*) THEN
BlockLength := 256
ELSIF QCDefPtr^.baud > 4 THEN
BlockLength := MaxLength;
ELSE
BlockLength := 512
END;
LOOP
Fi := Open(ThisFile^.Name);
IF Fi < MAX(CARDINAL) THEN
BlockZeroLen :=
CreateBlock[ZModem](ThisFile^.Name, FileName, Buffer );
GotFile := BlockZeroLen > 0
ELSE
GotFile := FALSE;
END;
IF NOT GotFile THEN
StatusMessage('Unable to find or open file', FALSE);
SendAckExit;
EXIT
END;
ShowFileName(ThisFile^.Name, FALSE);
DataRegisters[FALSE, DataLeft] := Size(Fi);
ShowTimeLeft( FALSE );
Cd := ZSendFile();
Close(Fi);
ShowTransferTime;
ThisFile := ThisFile^.Next;
IF (Cd = zrinit) OR (Cd = zskip) THEN
IF ThisFile = NIL THEN
SendAckExit;
EXIT
END
ELSE
ZSendCan;
EXIT
END
END;
DISPOSE( Buffer );
StopDisplay;
END SendZmodem;
END QCzm.